home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / VIDEO / FPAL.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-15  |  5KB  |  190 lines
  1. unit FPal;
  2. interface
  3. uses
  4.    Objects;
  5. const
  6.    Top                                             =     63;
  7.    FPOon                                           =     1.00;
  8.    FPGon                                           =     0.24;
  9.    FPNon                                           =     0.00;
  10.  
  11.    FPCycTop                                        =     FPOon;
  12.    FPCycBot                                        =     FPNon;
  13. type
  14.    RFPRgb=record
  15.       Red                                          ,
  16.       Green                                        ,
  17.       Blue                                         :     Real;
  18.    end;
  19.  
  20.    PFPPal=^TFPPal;
  21.    TFPPal=object(TObject)
  22.       Spot                                         :     Byte;
  23.       Red                                          ,
  24.       Green                                        ,
  25.       Blue                                         :     Real;
  26.     constructor Init(n:Byte);
  27.       procedure Copy;                                    virtual;
  28.       procedure Push;                                    virtual;
  29.       procedure This(a,b,c:Real);                        virtual;
  30.       procedure That(var a,b,c:Real);                    virtual;
  31.    end;
  32.    PFPPla=^TFPPla;
  33.    TFPPla=object(TFPPal)
  34.       cRed                                         ,
  35.       cGreen                                       ,
  36.       cBlue                                        :     Integer;
  37.     constructor Init(n:Byte);
  38.       procedure Cycle;                                   virtual;
  39.    end;
  40.  
  41.    AFPPalette=array [0..255] of TFPPal;
  42.    AFPPlaette=array [0..255] of TFPPla;
  43.  
  44.    PFPPalette=^TFPPalette;
  45.    TFPPalette=object(TObject)
  46.       Pals                                         :     AFPPalette;
  47.     constructor Init;
  48.       procedure Copy;                                    virtual;
  49.       procedure Push;                                    virtual;
  50.       procedure ThisAt(a:Byte; b,c,d:Real);              virtual;
  51.       procedure ThatAt(a:Byte; var b,c,d:Real);          virtual;
  52.    end;
  53.    PFPPlaette=^TFPPlaette;
  54.    TFPPlaette=object(TObject)
  55.       Pals                                         :     AFPPlaette;
  56.     constructor Init;
  57.       procedure Copy;                                    virtual;
  58.       procedure Push;                                    virtual;
  59.       procedure ThisAt(a:Byte; b,c,d:Real);              virtual;
  60.       procedure ThatAt(a:Byte; var b,c,d:Real);          virtual;
  61.       procedure Cycle;                                   virtual;
  62.    end;
  63.  
  64.  
  65.  
  66. implementation
  67. {TObject.TFPPal}
  68. constructor TFPPal.Init(n:Byte);
  69. begin
  70.    inherited Init;
  71.    Spot:=n;
  72. end;
  73. procedure   TFPPal.Copy;
  74. begin
  75.    Port[$3c7]:=Spot;
  76.    Red:=Port[$3c9]/Top;
  77.    Green:=Port[$3c9]/Top;
  78.    Blue:=Port[$3c9]/Top;
  79. end;
  80. procedure   TFPPal.Push;
  81. begin
  82.    Port[$3c8]:=Spot;
  83.    Port[$3c9]:=Round(Red*Top);
  84.    Port[$3c9]:=Round(Green*Top);
  85.    Port[$3c9]:=Round(Blue*Top);
  86. end;
  87. procedure   TFPPal.This(a,b,c:Real);
  88. begin
  89.    Red:=a/100;
  90.    Green:=b/100;
  91.    Blue:=c/100;
  92.    Push;
  93. end;
  94. procedure   TFPPal.That(var a,b,c:Real);
  95. begin
  96.    Copy;
  97.    a:=Red*100;
  98.    b:=Green*100;
  99.    c:=Blue*100;
  100. end;
  101. {TFPPal.TFPPla}
  102. constructor TFPPla.Init(n:Byte);
  103. begin
  104.    inherited Init(n);
  105.    cRed:=-1;
  106.    cGreen:=-1;
  107.    cBlue:=-1;
  108. end;
  109. procedure   TFPPla.Cycle;
  110. begin
  111.    if (cRed=-1) and (Red-0.01<FPCycBot)     then cRed:=-1*cRed;
  112.    if (cREd=1)  and (Red+0.01>FPCycTop)     then cRed:=-1*cRed;
  113.    if (cGreen=-1) and (Green-0.01<FPCycBot) then cGreen:=-1*cGreen;
  114.    if (cGreen=1) and (Green+0.01>FPCycTop)  then cGreen:=-1*cGreen;
  115.    if (cBlue=-1) and (Blue-0.01<FPCycBot)   then cBlue:=-1*cBlue;
  116.    if (cBlue=1) and (Blue+0.01>FPCycTop)    then cBlue:=-1*cBlue;
  117.    This(100*Red+cRed,100*Green+cGreen,100*Blue+cBlue);
  118. end;
  119.  
  120. {TObject.TFPPalette}
  121. constructor TFPPalette.Init;
  122. var
  123.    a:Byte;
  124. begin
  125.    inherited Init;
  126.    for a:=0 to 255 do
  127.       Pals[a].Init(a);
  128. end;
  129. procedure   TFPPalette.Copy;
  130. var
  131.    a:Byte;
  132. begin
  133.    for a:=0 to 255 do
  134.       Pals[a].Copy;
  135. end;
  136. procedure   TFPPalette.Push;
  137. var
  138.    a:Byte;
  139. begin
  140.    for a:=0 to 255 do
  141.       Pals[a].Push;
  142. end;
  143. procedure   TFPPalette.ThisAt(a:Byte; b,c,d:Real);
  144. begin
  145.    Pals[a].This(b,c,d);
  146. end;
  147. procedure   TFPPalette.ThatAt(a:Byte; var b,c,d:Real);
  148. begin
  149.    Pals[a].That(b,c,d);
  150. end;
  151. {TObject.TFPPlaette}
  152. constructor TFPPlaette.Init;
  153. var
  154.    a:Byte;
  155. begin
  156.    inherited Init;
  157.    for a:=0 to 255 do
  158.       Pals[a].Init(a);
  159. end;
  160. procedure   TFPPlaette.Copy;
  161. var
  162.    a:Byte;
  163. begin
  164.    for a:=0 to 255 do
  165.       Pals[a].Copy;
  166. end;
  167. procedure   TFPPlaette.Push;
  168. var
  169.    a:Byte;
  170. begin
  171.    for a:=0 to 255 do
  172.       Pals[a].Push;
  173. end;
  174. procedure   TFPPlaette.ThisAt(a:Byte; b,c,d:Real);
  175. begin
  176.    Pals[a].This(b,c,d);
  177. end;
  178. procedure   TFPPlaette.ThatAt(a:Byte; var b,c,d:Real);
  179. begin
  180.    Pals[a].That(b,c,d);
  181. end;
  182. procedure   TFPPlaette.Cycle;
  183. var
  184.    a:Byte;
  185. begin
  186.    for a:=0 to 255 do
  187.       Pals[a].Cycle;
  188. end;
  189.  
  190. end.